(DEFPROP FORLSPFNS
 (FORLSPFNS (SPECIAL *IF'SL)
	    DEFLIST
	    RPLACNODE
	    MAKEMAKECOPY
	    REMOVEIS
	    RECORD
	    RECDO
	    REMOVEOF
	    COMPOSE
	    COMPOSE1
	    COMPOSE2
	    COMPOSE3
	    COMPOSE4
	    #CONS
	    #REPLACE
	    VARNAME
	    GONEXTN
	    PLUSSIGNTESTSET
	    PLUSSIGNPV
	    INITL
	    PLUSSIGNNEXT
	    *FOR
	    |
	    CONDIT
	    SETIT
	    NEGATE
	    *IF
	    THENCLAUSE
	    QUOTEIT1
	    QUOTEIT2
	    FOR
	    IF
	    REPLACE
	    FULLEXPANSION
	    DEFAULT
	    GSET
	    ADVISE
	    ADVISE1
	    SAVEFN1
	    ARGLIST
	    NARGS
	    FIRSTN)
VALUE)

(SPECIAL *IF'SL)

(DEFPROP DEFLIST
 (LAMBDA(L PROP)
  (PROG	(VAL)
   LP	(COND ((NULL L) (RETURN VAL)))
	(PUTPROP (CAAR L) (CADAR L) PROP)
	(SETQ VAL (CONS (CAAR L) VAL))
	(SETQ L (CDR L))
	(GO LP)))
EXPR)

(DEFPROP RPLACNODE
 (LAMBDA (OLD NEW) (PROG2 (RPLACA OLD (CAR NEW)) (RPLACD OLD (CDR NEW))))
EXPR)

(DEFPROP MAKEMAKECOPY
 (LAMBDA(X)
  (COND	((MEMQ (CAR X) (QUOTE (LIST COPY))) X)
	((AND (EQ (CAR X) (QUOTE APPEND)) (CDDR X)) X)
	(T (LIST (QUOTE APPEND) X NIL))))
EXPR)

(DEFPROP REMOVEIS
 (LAMBDA(FORM)
  (COND	((NULL FORM) NIL)
	((EQ (CAR FORM) (QUOTE IS)) (REMOVEIS (CDR FORM)))
	((EQ (CAR FORM) (QUOTE =)) (REMOVEIS (CDR FORM)))
	(T (CONS (CAR FORM) (REMOVEIS (CDR FORM))))))
EXPR)

(DEFPROP RECORD
 (LAMBDA(NAME FIELD)
  (PROG	NIL
	(PUTPROP NAME FIELD (QUOTE RECORD))
	(PUTPROP NAME
		 (LIST (QUOTE LAMBDA)
		       (QUOTE (RECORDVAR))
		       (LIST (QUOTE COMPOSE) (QUOTE (REMOVEIS RECORDVAR)) (LIST (QUOTE QUOTE) FIELD)))
		 (QUOTE MACRO))
	(RECDO FIELD (QUOTE X))))
EXPR)

(DEFPROP RECDO
 (LAMBDA(FORMAT DEF)
  (COND	((NULL FORMAT) NIL)
	((NOT (ATOM FORMAT))
	 (RECDO (CAR FORMAT) (LIST (QUOTE CAR) DEF))
	 (RECDO (CDR FORMAT) (LIST (QUOTE CDR) DEF)))
	(T
	 (PUTPROP
	  FORMAT
	  (LIST	(QUOTE LAMBDA)
		(QUOTE (RECORDFIELDVAR))
		(LIST (QUOTE SUBST)
		      (QUOTE
		       (COND ((NULL (CDDR (SETQ RECORDFIELDVAR (REMOVEOF RECORDFIELDVAR))))
			      (CADR RECORDFIELDVAR))
			     (T (CDR RECORDFIELDVAR))))
		      (QUOTE (QUOTE X))
		      (LIST (QUOTE QUOTE) DEF)))
	  (QUOTE MACRO)))))
EXPR)

(DEFPROP REMOVEOF
 (LAMBDA(L)
  (COND ((NULL L) NIL) ((EQ (CAR L) (QUOTE OF)) (REMOVEOF (CDR L))) (T (CONS (CAR L) (REMOVEOF (CDR L))))))
EXPR)

(DEFPROP COMPOSE
 (LAMBDA(L FIELD)
  (COND	((EQ (CADR L) (QUOTE FROM))
	 (COND ((ATOM (CADDR L)) (COMPOSE1 L FIELD (CADDR L)))
	       (T
		(LIST (LIST (QUOTE LAMBDA) (QUOTE (COMPOSEVAR)) (COMPOSE1 L FIELD (QUOTE COMPOSEVAR)))
		      (CADDR L)))))
	(T (COMPOSE1 L FIELD (QUOTE COMPOSEVAR)))))
EXPR)

(DEFPROP COMPOSE1
 (LAMBDA(L FIELD DEF)
  (PROG (K) (RETURN (COND ((SETQ K (COMPOSE2 L FIELD DEF)) (CAR K)) (T (COMPOSE3 L FIELD DEF))))))
EXPR)

(DEFPROP COMPOSE2
 (LAMBDA(L FIELD DEF)
  (COND	((NULL FIELD) NIL)
	((ATOM FIELD) (COND ((GET L FIELD) (LIST (SUBST DEF (QUOTE **) (GET L FIELD)))) (T NIL)))
	((EQ (CAR FIELD) (QUOTE ID)) (LIST (LIST (QUOTE QUOTE) (CDR FIELD))))
	(T
	 (PROG (KA KD)
	       (SETQ KD (COMPOSE2 L (CDR FIELD) (LIST (QUOTE CDR) DEF)))
	       (SETQ KA (COMPOSE2 L (CAR FIELD) (LIST (QUOTE CAR) DEF)))
	       (COND ((AND (NULL KA) (NULL KD)) (RETURN NIL)))
	       (RETURN
		(LIST
		 (#CONS	(COND (KA (CAR KA)) (T (COMPOSE1 L (CAR FIELD) (LIST (QUOTE CAR) DEF))))
			(COND (KD (CAR KD)) (T (COMPOSE1 L (CDR FIELD) (LIST (QUOTE CDR) DEF)))))))))))
EXPR)

(DEFPROP COMPOSE3
 (LAMBDA (L FIELD DEF) (COND ((EQ (QUOTE FROM) (CADR L)) DEF) (T (COMPOSE4 FIELD))))
EXPR)

(DEFPROP COMPOSE4
 (LAMBDA(FIELD)
  (COND	((NULL FIELD) NIL)
	((ATOM FIELD)
	 ((LAMBDA (X) (COND (X (LIST (QUOTE QUOTE) (COPY X))) (T NIL))) (GET FIELD (QUOTE RECDEFAULT))))
	(T (#CONS (COMPOSE4 (CAR FIELD)) (COMPOSE4 (CDR FIELD))))))
EXPR)

(DEFPROP #CONS
 (LAMBDA(CARPART CDRPART)
  (COND	((NOT CDRPART) (LIST (QUOTE LIST) CARPART))
	((EQ (CAR CDRPART) (QUOTE LIST)) (CONS (QUOTE LIST) (CONS CARPART (CDR CDRPART))))
	(T (LIST (QUOTE CONS) CARPART CDRPART))))
EXPR)

(DEFPROP #REPLACE
 (LAMBDA(CARPART CDRPART)
  (COND	((NULL CARPART) CDRPART)
	((NULL CDRPART) CARPART)
	((AND (EQ (CAR CARPART) (QUOTE RPLACA))
	      (EQ (CAR CDRPART) (QUOTE RPLACD))
	      (EQUAL (CADR CARPART) (CADR CDRPART)))
	 (LIST (QUOTE RPLACD) CARPART (CADDR CDRPART)))
	(T (LIST (QUOTE PROG2) CARPART CDRPART))))
EXPR)

(DEFPROP VARNAME
 (LAMBDA (VARNL) (LIST (QUOTE |) (CADR VARNL) (QUOTE VAR)))
MACRO)

(DEFPROP GONEXTN
 (LAMBDA (DUMMY) (QUOTE (LIST (QUOTE GO) (COND ((EQUAL N 1.) (QUOTE RETURN)) (T (| (QUOTE NEXT) (SUB1 N)))))))
MACRO)

(DEFPROP PLUSSIGNTESTSET
 (LAMBDA(TSLS)
  (LIST (QUOTE CAR) (LIST (QUOTE SETQ) (QUOTE TESTSET) (LIST (QUOTE CONS) (CADR TSLS) (QUOTE TESTSET)))))
MACRO)

(DEFPROP PLUSSIGNPV
 (LAMBDA (PVL) (LIST (QUOTE CAR) (LIST (QUOTE SETQ) (QUOTE PV) (LIST (QUOTE CONS) (CADR PVL) (QUOTE PV)))))
MACRO)

(DEFPROP INITL
 (LAMBDA(INITLLS)
  (LIST	(QUOTE PROG1)
	(LIST (QUOTE SETQ) (QUOTE TEM) (CADR INITLLS))
	(LIST (QUOTE SETQ)
	      (QUOTE INIT)
	      (LIST (QUOTE CONS) (LIST (QUOTE SETIT) (QUOTE TEM) (CADDR INITLLS)) (QUOTE INIT)))))
MACRO)

(DEFPROP PLUSSIGNNEXT
 (LAMBDA(ITEMLIST)
  (LIST (QUOTE CAR) (LIST (QUOTE SETQ) (QUOTE NEXT) (LIST (QUOTE CONS) (CADR ITEMLIST) (QUOTE NEXT)))))
MACRO)

(DEFPROP *FOR
 (LAMBDA(L)
  (PROG	(N FV PV EPILOGUE PROLOGUE DOFORM DOTYPE VAR RANGE LST VARNEXT NEXT NEXTS N2 N3 INIT TESTSET DOVAL TEM)
	(SETQ N 1.)
   FORLOOP
	(COND ((EQ (CAR L) (QUOTE NEW)) (PLUSSIGNPV (CAR (SETQ L (CDR L))))))
	(SETQ VAR (CAR L))
	(SETQ RANGE (CADDR L))
	(PLUSSIGNNEXT (SETQ VARNEXT (VARNAME (QUOTE NEXT))))
	(COND ((EQ (CADR L) (QUOTE IN))
	       (PLUSSIGNTESTSET
		(CONDIT (NEGATE (INITL (PLUSSIGNPV (SETQ LST (VARNAME (QUOTE LIST)))) RANGE)) (GONEXTN)))
	       (PLUSSIGNTESTSET (SETIT VAR (LIST (QUOTE CAR) LST)))
	       (PLUSSIGNNEXT (SETIT LST (LIST (QUOTE CDR) LST))))
	      ((EQ (CADR L) (QUOTE ON))
	       (PLUSSIGNTESTSET (CONDIT (NEGATE VAR) (GONEXTN)))
	       (PLUSSIGNNEXT (SETIT (INITL VAR RANGE) (LIST (QUOTE CDR) VAR))))
	      ((MEMB (CADR L) (QUOTE (:= ←)))
	       (SETQ N2
		     (COND ((ATOM (CADR RANGE)) (CADR RANGE))
			   (T (INITL (PLUSSIGNPV (VARNAME (QUOTE MAX))) (CADR RANGE)))))
	       (SETQ N3
		     (COND ((CDDR RANGE)
			    (COND ((ATOM (CADDR RANGE)) (CADDR RANGE))
				  (T (INITL (PLUSSIGNPV (VARNAME (QUOTE INC))) (CADDR RANGE)))))
			   ((AND (NUMBERP (CAR RANGE))
				 (NUMBERP (CADR RANGE))
				 (GREATERP (CAR RANGE) (CADR RANGE)))
			    -1.)
			   (T 1.)))
	       (INITL VAR (CAR RANGE))
	       (AND (NOT (MEMB N2 (QUOTE (∞ INFINITY))))
		    (PLUSSIGNTESTSET
		     (CONDIT (COND ((NOT (NUMBERP N3))
				    (LIST (QUOTE COND)
					  (LIST (LIST (QUOTE MINUSP) N3) (LIST (QUOTE LESSP) VAR N2))
					  (LIST	T
						(LIST (QUOTE OR)
						      (LIST (QUOTE ZEROP) N3)
						      (LIST (QUOTE GREATERP) VAR N2)))))
				   ((MINUSP N3) (LIST (QUOTE LESSP) VAR N2))
				   (T (LIST (QUOTE GREATERP) VAR N2)))
			     (GONEXTN))))
	       (PLUSSIGNNEXT (SETIT VAR (LIST (QUOTE PLUS) VAR N3))))
	      ((EQ (CADR L) (QUOTE IS)) (PLUSSIGNTESTSET (SETIT VAR RANGE)))
	      (T (ERROR (QUOTE "INVALID FOR TYPE"))))
	(SETQ L (CDDDR L))
   ASLOOP
	(COND ((EQ (CAR L) (QUOTE AS))
	       (SETQ L (CDR L))
	       (SETQ NEXTS (APPEND NEXTS NEXT))
	       (SETQ NEXT NIL)
	       (GO FORLOOP))
	      ((MEMQ (CAR L) (QUOTE (IF WHEN)))
	       (PLUSSIGNTESTSET (CONDIT (NEGATE (CADR L)) (LIST (QUOTE GO) VARNEXT)))
	       (SETQ L (CDDR L)))
	      ((EQ (CAR L) (QUOTE UNTIL)) (PLUSSIGNNEXT (CONDIT (CADR L) (GONEXTN))) (SETQ L (CDDR L)))
	      ((EQ (CAR L) (QUOTE WHILE))
	       (PLUSSIGNTESTSET (CONDIT (NEGATE (CADR L)) (GONEXTN)))
	       (SETQ L (CDDR L)))
	      (T (GO FORTEST)))
	(GO ASLOOP)
   FORTEST
	(SETQ PROLOGUE (APPEND TESTSET (LIST (| (QUOTE LOOP) N)) INIT PROLOGUE))
	(SETQ EPILOGUE
	      (CONS (| (QUOTE NEXT) N)
		    (APPEND (REVERSE NEXT)
			    (REVERSE NEXTS)
			    (CONS (LIST (QUOTE GO) (| (QUOTE LOOP) N)) EPILOGUE))))
	(SETQ TESTSET (SETQ INIT (SETQ NEXT (SETQ NEXTS NIL))))
	(COND ((EQ (CAR L) (QUOTE FOR)) (SETQ L (CDR L)) (SETQ N (ADD1 N)) (GO FORLOOP)))
	(SETQ DOTYPE (CAR L))
	(SETQ DOVAL (CAR (LAST L)))
	(PLUSSIGNPV (QUOTE FOR-VALUE))
	(SETQ FV (QUOTE FOR-VALUE))
	(SETQ DOFORM
	      (COND ((EQ DOTYPE (QUOTE OR)) (CONDIT (SETIT (QUOTE FOR-VALUE) DOVAL) (QUOTE (RETURN FOR-VALUE))))
		    ((EQ DOTYPE (QUOTE AND))
		     (INITL (QUOTE FOR-VALUE) T)
		     (CONDIT (NEGATE (SETIT (QUOTE FOR-VALUE) DOVAL)) (QUOTE (RETURN NIL))))
		    ((MEMQ DOTYPE (QUOTE (PROGN PROG2))) (SETIT (QUOTE FOR-VALUE) DOVAL))
		    ((EQ DOTYPE (QUOTE DO)) DOVAL)
		    (T
		     (SETIT (QUOTE FOR-VALUE)
			    (COND ((EQ DOTYPE (QUOTE LIST))
				   (LIST (QUOTE NCONC) (QUOTE FOR-VALUE) (LIST (QUOTE LIST) DOVAL)))
				  ((EQ DOTYPE (QUOTE NCONC)) (LIST (QUOTE NCONC) (QUOTE FOR-VALUE) DOVAL))
				  ((EQ DOTYPE (QUOTE XLIST)) (LIST (QUOTE CONS) DOVAL (QUOTE FOR-VALUE)))
				  ((EQ DOTYPE (QUOTE APPEND))
				   (LIST (QUOTE NCONC) (QUOTE FOR-VALUE) (MAKEMAKECOPY DOVAL)))
				  (T (LIST DOTYPE DOVAL (QUOTE FOR-VALUE))))))))
	(COND ((EQ (CAR (SETQ L (CDR L))) (QUOTE FIRST)) (INITL (QUOTE FOR-VALUE) (CADR L)) (SETQ L (CDDR L)))
	      ((MEMQ DOTYPE (QUOTE (PLUS IPLUS TIMES ITIMES MAX MIN)))
	       (INITL (QUOTE FOR-VALUE)
		      (CDR
		       (ASSOC DOTYPE
			      (QUOTE
			       ((PLUS . 0.) (MAX . -99999.)
					    (MIN . 99999.)
					    (IPLUS . 0.)
					    (TIMES . 1.)
					    (ITIMES . 1.))))))))
	(RETURN
	 (CONS (QUOTE PROG)
	       (CONS PV
		     (APPEND INIT
			     (REVERSE PROLOGUE)
			     (REVERSE (CDR (REVERSE L)))
			     (LIST DOFORM)
			     EPILOGUE
			     (LIST (QUOTE RETURN) (LIST (QUOTE RETURN) FV))))))))
EXPR)

(DEFPROP |
 (LAMBDA (STR VAL) (READLIST (NCONC (EXPLODE STR) (CONS (QUOTE *) (EXPLODE VAL)))))
EXPR)

(DEFPROP CONDIT
 (LAMBDA (PRD DO) (LIST (QUOTE COND) (LIST PRD DO)))
EXPR)

(DEFPROP SETIT
 (LAMBDA (VAR VAL) (COND ((NOT (EQUAL VAR VAL)) (LIST (QUOTE SETQ) VAR VAL)) (T NIL)))
EXPR)

(DEFPROP NEGATE
 (LAMBDA (EXP) (COND ((MEMQ (CAR EXP) (QUOTE (NOT NULL))) (CADR EXP)) (T (LIST (QUOTE NOT) EXP))))
EXPR)

(DEFPROP *IF
 (LAMBDA(*IF'SL)
  (COND	(*IF'SL
	 (CONS (CONS (CAR *IF'SL)
		     (COND ((NOT (EQ (CADR *IF'SL) (QUOTE THEN)))
			    (ERROR *IF'SL (QUOTE "NO CORRESPONDING THEN IN IF")))
			   (T (SETQ *IF'SL (CDDR *IF'SL)) (THENCLAUSE))))
	       (COND ((NULL *IF'SL) NIL)
		     ((EQ (CAR *IF'SL) (QUOTE ELSEIF)) (*IF (CDR *IF'SL)))
		     ((EQ (CAR (SETQ *IF'SL (CDR *IF'SL))) (QUOTE IF)) (*IF (CDR *IF'SL)))
		     (T (LIST (CONS T (THENCLAUSE)))))))
	(T NIL)))
EXPR)

(DEFPROP THENCLAUSE
 (LAMBDA NIL
  (COND	((OR (NULL *IF'SL) (MEMQ (CAR *IF'SL) (QUOTE (ELSE ELSEIF)))) (LIST NIL))
	((OR (NOT (CDR *IF'SL)) (MEMQ (CADR *IF'SL) (QUOTE (ELSE ELSEIF))))
	 (PROG1 (LIST (CAR *IF'SL)) (SETQ *IF'SL (CDR *IF'SL))))
	(T (CONS (CAR *IF'SL) (PROG2 (SETQ *IF'SL (CDR *IF'SL)) (THENCLAUSE))))))
EXPR)

(DEFPROP QUOTEIT1
 (LAMBDA(X M)
  (COND ((OR (NULL X) (NUMBERP X) (EQ X T)) X) ((SETQ M (QUOTEIT2 X M)) M) (T (LIST (QUOTE QUOTE) X))))
EXPR)

(DEFPROP QUOTEIT2
 (LAMBDA(X N)
  (COND	((ATOM X) NIL)
	((EQ (CAR X) (QUOTE ¬))
	 (COND ((ATOM (CDR X)) (CDR X))
	       ((NULL (CDDR X)) (LIST (QUOTE LIST) (CADR X)))
	       (T
		((LAMBDA(D E)
		  (COND	((EQ (CAR D) (QUOTE LIST)) (CONS (QUOTE LIST) (CONS E (CDR D))))
			(T (LIST (QUOTE CONS) E D))))
		 (QUOTEIT1 (CDDR X))
		 (CADR X)))))
	((NULL (CDR X)) (COND ((SETQ N (QUOTEIT2 (CAR X) N)) (LIST (QUOTE LIST) N)) (T NIL)))
	(T
	 (PROG (M)
	       (SETQ M (QUOTEIT2 (CAR X) N))
	       (SETQ N (QUOTEIT2 (CDR X) N))
	       (COND ((AND (NULL M) (NULL N)) (RETURN NIL)))
	       (COND
		((AND (NULL M) (SETQ M (CAR X)) (NOT (NUMBERP M)) (NOT (EQ M T)))
		 (SETQ M (LIST (QUOTE QUOTE) M))))
	       (RETURN
		(COND ((EQ (CAR N) (QUOTE LIST)) (CONS (CAR N) (CONS M (CDR N))))
		      (T
		       (LIST (QUOTE CONS)
			     M
			     (COND ((AND (NULL N) (SETQ N (CDR X)) (NOT (NUMBERP N)) (NOT (EQ N T)))
				    (LIST (QUOTE QUOTE) N))
				   (T N))))))))))
EXPR)

(DEFPROP FOR
 (LAMBDA (FOR-EXPRESSION) (*FOR (CDR FOR-EXPRESSION)))
MACRO)

(DEFPROP IF
 (LAMBDA (IF-EXPRESSION) (RPLACNODE IF-EXPRESSION (CONS (QUOTE COND) (*IF (CDR IF-EXPRESSION)))))
MACRO)

(DEFPROP REPLACE
 (LAMBDA(REPLACEXP)
  (PROG	(REPLACE1 REPLACE2)
	(SETQ REPLACE1 (FULLEXPANSION (CADR REPLACEXP)))
	(SETQ REPLACE2 (CADDR REPLACEXP))
	(RETURN
	 (LIST (COND ((EQ (CAR REPLACE1) (QUOTE CAR)) (QUOTE RPLACA))
		     ((EQ (CAR REPLACE1) (QUOTE CDR)) (QUOTE RPLACD))
		     (ERROR (QUOTE "REPLACE CAN'T") (LIST REPLACE1 REPLACE2)))
	       (CADR REPLACE1)
	       REPLACE2))))
MACRO)

(DEFPROP FULLEXPANSION
 (LAMBDA(X)
  (COND	((MEMQ (CAR X)
	       (QUOTE
		(CAAR CADR
		      CDAR
		      CDDR
		      CDDAR
		      CDDDR
		      CDDDAR
		      CDDDDR
		      CADDAR
		      CADDDR
		      CADAR
		      CADDR
		      CDADAR
		      CDADDR
		      CAADAR
		      CAADDR
		      CDAAR
		      CDADR
		      CDDAAR
		      CDDADR
		      CADAAR
		      CADADR
		      CAAAR
		      CAADR
		      CDAAAR
		      CDAADR
		      CAAAAR
		      CAAADR)))
	 (LIST (READLIST (LIST (QUOTE C) (CADR (EXPLODE (CAR X))) (QUOTE R)))
	       (LIST (READLIST (CONS (QUOTE C) (CDDR (EXPLODE (CAR X))))) (CADR X))))
	((GET (CAR X) (QUOTE MACRO)) (FULLEXPANSION (APPLY (GET (CAR X) (QUOTE MACRO)) (LIST X))))
	(T X)))
EXPR)

(DEFPROP DEFAULT
 (LAMBDA (FIELD VALUE) (DEFLIST (LIST VALUE) (QUOTE RECDEFAULT)))
EXPR)

(DEFPROP GSET
 (LAMBDA(VAR VAL)
  (PROG2 (COND ((GET VAR (QUOTE SPECIAL))) (T (PUTPROP VAR (QUOTE T) (QUOTE SPECIAL)))) (SET VAR VAL)))
EXPR)

(DEFPROP ADVISE
 (LAMBDA(FN WHEN WHAT)
  (PUTPROP FN
	   (LIST (QUOTE LAMBDA)
		 (ARGLIST FN)
		 (LIST (QUOTE PROG)
		       (CONS (QUOTE !VALUE) (COND ((EQ WHEN (QUOTE BIND)) WHAT) (T NIL)))
		       (LIST (QUOTE SETQ)
			     (QUOTE !VALUE)
			     (LIST (QUOTE PROG)
				   NIL
				   (COND ((EQ WHEN (QUOTE BEFORE)) WHAT) (T NIL))
				   (LIST (QUOTE RETURN) (SAVEFN1 FN (ARGLIST FN)))))
		       (COND ((EQ WHEN (QUOTE AFTER)) WHAT) (T NIL))
		       (QUOTE (RETURN !VALUE))))
	   (QUOTE EXPR)))
EXPR)

(DEFPROP ADVISE1
 (LAMBDA(FN WHEN ARGLIST WHAT)
  (PUTPROP FN
	   (LIST (QUOTE LAMBDA)
		 ARGLIST
		 (LIST (QUOTE PROG)
		       (CONS (QUOTE !VALUE) (COND ((EQ WHEN (QUOTE BIND)) WHAT) (T NIL)))
		       (LIST (QUOTE SETQ)
			     (QUOTE !VALUE)
			     (LIST (QUOTE PROG)
				   NIL
				   (COND ((EQ WHEN (QUOTE BEFORE)) WHAT) (T NIL))
				   (LIST (QUOTE RETURN) (SAVEFN1 FN ARGLIST))))
		       (COND ((EQ WHEN (QUOTE AFTER)) WHAT) (T NIL))
		       (QUOTE (RETURN !VALUE))))
	   (QUOTE EXPR)))
EXPR)

(DEFPROP SAVEFN1
 (LAMBDA(FN ARGLIST)
  (PROG	(AT)
	(SETQ AT (INTERN (GENSYM)))
	(COND ((GET FN (QUOTE EXPR)) (PUTPROP AT (GET FN (QUOTE EXPR)) (QUOTE EXPR)))
	      ((GET FN (QUOTE SUBR)) (PUTPROP AT (GET FN (QUOTE SUBR)) (QUOTE SUBR))))
	(RETURN (CONS AT ARGLIST))))
EXPR)

(DEFPROP ARGLIST
 (LAMBDA(FN)
  (COND	((GET FN (QUOTE EXPR)) (CADR (GET FN (QUOTE EXPR))))
	(T
	 (OR# (GET FN (QUOTE ARGLIST))
	      (PUTPROP FN (PROGN (PRINT FN) (PRINC (QUOTE / ARGLIST?)) (READ)) (QUOTE ARGLIST))))))
EXPR)

(DEFPROP NARGS
 (LAMBDA (FN) (COND ((GET FN (QUOTE EXPR)) (LENGTH (CADR (GET FN (QUOTE EXPR))))) (T 5.)))
EXPR)

(DEFPROP FIRSTN
 (LAMBDA (L N) (COND ((EQUAL N 0.) NIL) (T (CONS (CAR L) (FIRSTN (CDR L) (SUB1 N))))))
EXPR)